(define-class type-class object
  (args name native-name)
  (fields name supertypes reversed-supertypes array-type native-name))

(define-class array-type-class type-class
  (args base-type)
  (fields base-type))

(define-method (initialize! (t array-type-class))
  (define b (base-type t))

  (set (supertypes t)
       (list t object-type))
  (set (reversed-supertypes t)
       (list object-type t))

  (set (name t) (name b))
  (set (native-name t)
       (string-append (native-name b)
		      "[]")))

(define (array-type-of type)
  (or (array-type type)
      (let ((at (new array-type-class type)))
	(set (array-type type)
	     at)
	at)))

(define (native-type-name name)
  (cond ((eq? name 'integer)
	 "int")
	((eq? name 'short)
	 "short")
	((eq? name 'boolean)
	 "bool")
	((eq? name 'float)
	 "double")
	((eq? name 'single-float)
	 "float")
	((eq? name 'character)
	 "char")
	((eq? name 'object)
	 "object")
	((eq? name 'void)
	 "void")
	((eq? name 'byte)
	 "byte")
	((eq? name 'signed-byte)
	 "sbyte")
	(else
	 (cs-style name #t))))

(define (make-type name)
  (new type-class name (native-type-name name)))

(define (class->type class)
  (or (class-type-object class)
      (let ((type (make-type (class-name class))))
	(set-class-type-object! class type)
	(let ((ancestors (map class->type
			      (class-ancestors class))))
	  (set (supertypes type) ancestors)
	  (set (reversed-supertypes type)
	       (reverse ancestors))
	  type))))

(define (make-primitive-type name parent)
  (let* ((type (make-type name))
	 (supers (cons type (supertypes parent))))
    (set (supertypes type) supers)
    (set (reversed-supertypes type)
	 (reverse supers))
    type))

(define object-type (class->type object))
(define float-type (make-primitive-type 'float object-type))
(define single-float-type (make-primitive-type 'single-float float-type))
(define integer-type (make-primitive-type 'integer single-float-type))
(define short-type (make-primitive-type 'short integer-type))
(define boolean-type (make-primitive-type 'boolean object-type))
(define character-type (make-primitive-type 'character object-type))
(define string-type (make-primitive-type 'string object-type))
(define void-type (make-primitive-type 'void object-type))
(define type-type (class->type type-class))
(define signed-byte-type (make-primitive-type 'signed-byte short-type))
(define byte-type (make-primitive-type 'byte signed-byte-type))

(define value-types
  (list float-type single-float-type integer-type short-type boolean-type
	character-type byte-type signed-byte-type))

(define (type-of-constant value)
  (cond ((integer? value)
	 integer-type)
	((number? value)
	 float-type)
	((memq value '(#t #f))
	 boolean-type)
	((string? value)
	 string-type)
	((char? value)
	 character-type)
	(else
	 (error "Constant of unknown type" value))))

;;;
;;; LEAST-UPPER-BOUND OF TWO TYPES
;;;

(define (type-lub type1 type2)
  (let loop ((supers1 (cdr (reversed-supertypes type1)))
	     (supers2 (cdr (reversed-supertypes type2)))
	     (type object-type))
    (if (or (null? supers1)
	    (null? supers2)
	    (not (eq? (car supers1)
		      (car supers2))))
	type
	(loop (cdr supers1)
	      (cdr supers2)
	      (car supers1)))))		; same as (car supers2)

(define (type-lub* types)
  (reduce type-lub (car types) (cdr types)))

;;;
;;; GREATEST-LOWER-BOUND OF TWO TYPES
;;;

(define (type-glb type1 type2 . maybe-error)
  (cond ((memq type1 (supertypes type2))
	 type2)
	((memq type2 (supertypes type1))
	 type1)
	(else
	 (if (null? maybe-error)
	     #f
	     ((car maybe-error))))))

(define (type-<=? lower upper)
  (memq upper (supertypes lower)))

;;;
;;; PROCEDURE TYPES
;;;

(define-class operoid-type type-class
  (methods propagate))

(define-class procedure-type operoid-type
  (methods result-type bound-arg-types))

(define-method (bound-arg-types (p procedure-type) exp args)
  #f)

(define-class arithmetic-type procedure-type
  (args name native-name))
;(define-method (result-type (t arithmetic-type) arg-types)
;  (type-lub* arg-types))
(define-method (result-type (t arithmetic-type) arg-types)
  (if (every (lambda (t) (eq? t integer-type))
	     arg-types)
      integer-type
      float-type))
(define-method (bound-arg-types (t arithmetic-type) exp args)
  (define t (type exp))			;this lets us propagate types backward
  (define (bound! arg)
    (bound-above! arg t))

  (for-each bound! args))

(define the-arithmetic-type (new arithmetic-type 'arithmetic-type "ArithmeticType"))
(set (supertypes the-arithmetic-type)
     (list the-arithmetic-type object-type))
(set (reversed-supertypes the-arithmetic-type)
     (list object-type the-arithmetic-type))

(define-class boolean-operator-type procedure-type
  (args name native-name))

(define-method (result-type (b boolean-operator-type) arg-types)
  boolean-type)

(define-method (bound-arg-types (b boolean-operator-type) exp args)
  (define (bound! x)
    (bound-above! x boolean-type))

  (for-each bound! args))

(define the-boolean-operator-type (new boolean-operator-type 'boolean-operator-type "Boolean-OperatorType"))
(set (supertypes the-boolean-operator-type)
     (list the-boolean-operator-type object-type))
(set (reversed-supertypes the-boolean-operator-type)
     (list object-type the-boolean-operator-type))

(define-class  conditional-operator-type procedure-type
  (args))

(define-method (result-type (c conditional-operator-type) arg-types)
  (cadr arg-types))

(define-class simple-procedure-type procedure-type
  (args name native-name result arg-types)
  (fields result arg-types))
(define-method (result-type (t simple-procedure-type) ignore)
  (result t))
(define-method (bound-arg-types (t simple-procedure-type) exp args)
  (define types (arg-types t))
  (unless (= (length args)
	     (length types))
    (error "Wrong number of arguments in call"
	   (unparse exp)
	   types))
  (for-each bound-above! args types))

(define (typify type-or-class)
  (if (class? type-or-class)
      (class->type type-or-class)
      type))

(define-syntax type-expression
  (syntax-rules (array-type integer float single-float string boolean character
		      object void type short byte signed-byte)
    ((type-expression (array-type ?t))
     (array-type-of (type-expression ?t)))
    ((type-expression (?stuff ...))
     (?stuff ...))
    ((type-expression integer)
     integer-type)
    ((type-expression short)
     short-type)
    ((type-expression float)
     float-type)
    ((type-expression single-float)
     single-float-type)
    ((type-expression byte)
     byte-type)
    ((type-expression signed-byte)
     signed-byte-type)
    ((type-expression string)
     string-type)
    ((type-expression boolean)
     boolean-type)
    ((type-expression character)
     character-type)
    ((type-expression object)
     object-type)
    ((type-expression void)
     void-type)
    ((type-expression type)
     type-type)
    ((type-expression ?x)
     ?x)))

(define (new-procedure-type type . args)
  (define t (apply new type 'procedure-type "ProcedureType" args))
  (set (supertypes t) (list t object))
  (set (reversed-supertypes t)
       (list object t))
  t)

(define (new-procedure-type-w/name type name . args)
  (define t (apply new type name (native-type-name name) args))
  (set (supertypes t) (list t object))
  (set (reversed-supertypes t)
       (list object t))
  t)

(define-syntax proc
  (syntax-rules ()
    ((proc (?arg-types ...) ?result-type)
     (new-procedure-type simple-procedure-type
			 (type-expression ?result-type)
			 (list (type-expression ?arg-types) ...)))
    ((proc ?name (?arg-types ...) ?result-type)
     (new-procedure-type-w/name simple-procedure-type ?name
				(type-expression ?result-type)
				(list (type-expression ?arg-types) ...)))))

(define-class user-type type-class
  (args name native-name constructor-arg-types)
  (fields constructor-arg-types))

(define user-type-table (make-table))

(define (simple-make-user-type name parent)
  (make-user-type name (native-type-name name)
		  parent
		  #f))

(define (make-user-type name native parent constructor-args)
  (define type
    (or (table-ref user-type-table name)
	(let ((type (new user-type
			 name native
			 constructor-args)))
	  (table-set! user-type-table name type)
	  type)))

  (set (constructor-arg-types type)
       constructor-args)
  (when native
    (set (native-name type) native))

  (let ((supers (cons type (supertypes parent))))
    (set (supertypes type) supers)
    (set (reversed-supertypes type)
	 (reverse supers))
    type))

(define-class new-operator-type operoid-type
  (args))

(define-class new-array-operator-type operoid-type
  (args))

(define-class vector-ref-type procedure-type
  (args))

(define-class as-operator-type operoid-type
  (args))

;;;;
;;;; UTILITIES
;;;;

(define (type-expression-value exp)
  (define (bad-type-expression)
    (error "Not a valid type expression" (unparse exp)))

  (when (or (pair? exp)
	    (symbol? exp))
    (set! exp (parse exp)))
  (cond ((is? exp type-type)
	 exp)
	((is? exp global-variable)
	 (let ((val (current-value exp)))
	   (if (is? val type-class)
	       val
	       (bad-type-expression))))
	((and (is? exp application)
	      (eq? (operator exp)
		   the-array-var))
	 (let ((args (arguments exp)))
	   (unless (= (length args) 1)
	     (bad-type-expression))
	   (array-type-of (type-expression-value (car args)))))
	(else
	 (bad-type-expression))))